perm filename CONGEN.F4[FOO,LMM] blob
sn#068172 filedate 1973-12-07 generic text, type C, neo UTF8
COMMENT ā VALID 00033 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 C CONGEN. COMMON AREAS.
C00011 00003 C CHOICE: DECISION ROUTINE
C00018 00004 SUBROUTINE GSCHAR (ICA)
C00019 00005 SUBROUTINE ADLINK
C00021 00006 SUBROUTINE ADBOND
C00022 00007 SUBROUTINE BONDCL
C00025 00008 SUBROUTINE ALTBOND (SKIP,BOND)
C00027 00009 SUBROUTINE ALTRING (M1,M2)
C00030 00010 SUBROUTINE EQCL (N1,N2,SYM)
C00032 00011 C DOEASY: MAIN LOOP IS HERE
C00045 00012 SUBROUTINE DELATOM
C00047 00013 SUBROUTINE CONTIG (FROMAR,TOAR,NUM,CNT)
C00049 00014 SUBROUTINE MINDIS (AR,NUM,MUM,MIN)
C00052 00015 SUBROUTINE NUCLEUS
C00055 00016 SUBROUTINE GMOL (II)
C00059 00017 SUBROUTINE MIRROR
C00060 00018 SUBROUTINE LINE (X1,Y1,X2,Y2,SYM)
C00064 00019 SUBROUTINE CLRAR
C00065 00020 SUBROUTINE GWOUT
C00068 00021 SUBROUTINE CSRG (MODE)
C00071 00022 SUBROUTINE RINGGG (MODE,BRATAR,BRATC,RET)
C00078 00023 SUBROUTINE BRANCH
C00080 00024 SUBROUTINE WO (I17)
C00082 00025 SUBROUTINE POSITION (CNT,STR,MODE,RET)
C00093 00026 SUBROUTINE NDIRECT (I1,I2,I3,CNT,NDIR)
C00097 00027 SUBROUTINE ND1 (I1,I2,I3,QAR,NDIR)
C00098 00028 SUBROUTINE INTERSECT (I1,I2,RET)
C00101 00029 SUBROUTINE RECPOS (LAT,NAT,RET)
C00112 00030 SUBROUTINE UNPOS (NC)
C00114 00031 SUBROUTINE ELIMEND
C00118 00032 SUBROUTINE SAFMAF
C00120 00033 SUBROUTINE NMORGAN
C00125 ENDMK
Cā;
C CONGEN. COMMON AREAS.
C
C *** *** * * *** ***** * *
C * * * * ** * * * * ** *
C * * * * * * * * * * *
C * * * * ** * **** * **
C * * * * * * ** * * *
C * * * * * * * * * * *
C *** *** * * *** ***** * *
C
C
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
COMMON /CFILLIM/ FILLIM,STRCLIM
COMMON /CFFF/ FILEU(80),FILE(80),BLK(80),WRD(80)
1 ,LIM(80)
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CFFXX/ FN,IEXT,HFILEN(40)
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CFILEN/ HNAM(14),TCH(7),FHNAM(11)
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20)
1 ,INCL,INCLA(20),INCLT(20,4)
COMMON /CATMSOR/ ATMSOR(106)
DATA (ATMSOR(I1),I1=1,106)/
1 13, 15, 18, 36, 27, 11, 62, 38, 14, 55,
1 44, 16, 37, 8, 1, 20, 89, 71, 65, 5,
1 59, 32, 52, 51, 22, 43, 42, 41, 40, 39,
1 6, 23,105,103, 90, 31, 87, 86, 84, 72,
1 12, 67, 9, 64, 63, 29, 61, 60, 28, 58,
1 57, 56, 24, 54, 53, 3, 30, 50, 49, 48,
1 47, 46, 45, 2,106, 7,104, 25,102,101,
1 100, 99, 98, 97, 96, 95, 94, 93, 92, 91,
1 4, 19, 88, 26, 10, 85, 17, 83, 82, 81,
1 80, 79, 78, 77, 76, 75, 74, 73, 21, 35,
1 70, 69, 68, 34, 66, 33/
COMMON /CPOSW/ POSW
COMMON /IO/ CID,COD,E2CID,ICNT,BOD
DATA CID,COD,E2CID /21,1,23/
C-------------------------------------------------------------------------------
C
C THE FOLLOWING BLOCK MUST NOT BE DISTURBED
C 12,033 WORDS
C
COMMON /CACL/ DUM(4),NEW(1024)
COMMON /CASA/ NUMB,AR(10,100),CDUM(3000)
COMMON /PUSH/ PDUM(3400)
COMMON /CRNGH/ RNGH(120)
COMMON /INA/INA(2)
COMMON /TRBLK/ RAR(256)
COMMON /DDF/DDFILE(10)
COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
1 ,Z(2,100),ATS(100),AT(100),ASS(100)
1 ,SUBQ(100),SUBS(100),SUBT(100)
COMMON /CAHA/ HOLDA(100),HOLDB(100),HOLDBB(100)
1 ,HOLDC(100),HOLDD(100),HOLDE(100),
1 R1MARK(100),R2MARK(100),R3MARK(100)
COMMON /MARK/ CT(20),MK(100)
COMMON /CEXT/ DR(10,100)
C
C
C
C-------------------------------------------------------------------------------
COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
COMMON /CBB/ BUFQ(2)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
COMMON /CATAS/ ATAS(106)
DATA (ATAS(I1),I1=1,106)/
1 'AC','AG','AL','AM','AR','AS','AT','AU','B','BA','BE','BI',
1 'BK','BR','C','CA','CD','CE','CF','CL','CM','CO','CR','CS',
1 'CU','D','DY','ER','ES','EU','F','FE','FM','FR','GA','GD',
1 'GE','H','HE','HF','HG','HO','I','IN','IR','K','KR','LA',
1 'LI','LU','LW','MD','MG','MN','MO','N','NA','NB','ND','NE',
1 'NI','NO','NP','O','OS','P','PA','PB','PD','PM','PO','PR',
1 'PT','PU','RA','RB','RE','RH','RN','RU','S','SB','SC','SE',
1 'SI','SM','SN','SR','T','TA','TB','TC','TE','TH','TI','TL',
1 'TM','U','V','W','XE','Y','YB','ZN','ZR',' '/
COMMON /QSCALE/ SCALE,SCC
IOMNI=0
IOFST=0
IOMDEV=0
SCC=60
POSW=1
QFLG=0
E2SW=2
BNCNT=1
FILLIM=80
STRCLIM=10000
TYPE 12212
12212 FORMAT(' DCRT/NIH'/' STRUCTURE RETRIEVAL PROGRAM '
1 /' TYPE YOUR 3 INITIALS XXX'/)
ACCEPT 1332,IEXT
1332 FORMAT(1A3)
IF(IEXT .EQ. ' ') IEXT='100'
DO 600 I1=1,4
SST(I1)=1
SHUNT(I1)=1
600 CONTINUE
SHUNT(5)=1
DO 609 I1=1,12
FSHUNT(I1)=1
609 CONTINUE
FSHUNT(12)=1
SW=0
INITF=1
DO 70 I1=1,1000
AREQ(I1)=0
70 CONTINUE
NUMB=0
CALL DOEASY
END
C CHOICE: DECISION ROUTINE
SUBROUTINE CHOICE (AT)
IMPLICIT INTEGER (A-Z)
COMMON /CREST/ LNUMB,STATE (1000)
COMMON /CNEWHLD/ SSTATE(1000)
COMMON /CFILLIM/ FILLIM,STRCLIM
COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CVTBAR/ VTB,DFSW
DATA DFSW /0/
COMMON /QSCALE/ SCALE,SCC
COMMON /PUSH/ NEWS(1024)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
1 ,DELTA
DATA LSYM /':'/
COMMON /CATAS/ ATAS(106)
COMMON /CGSC/ ATAR(80)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20)
1 ,INCL,INCLA(20),INCLT(20,4)
COMMON /MARK/ TEMP(4)
DATA LEV /8/
DATA TOGG /2/
COMMON /IO/ CID,COD
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
DATA (STT(I1),I1=1,8) /
1 'RING','STIT','STIT','SUBST',
1 'NUC','PATT','SEQ','PATT'/
DIMENSION AREQ (10)
EQUIVALENCE (AREQ(1),AR(1,1))
CALL GSCHAR (AT)
C----------------------------------------------------------------- SYM
IF(AT .NE. 'SYM') GOTO 644
IF(LSYM .EQ. ':') GOTO 645
LSYM=':'
GOTO 644
645 LSYM='*'
C----------------------------------------------------------------- MLIM
644 IF(AT .NE. 'MLIM') GOTO 416
TYPE 417
417 FORMAT(' MAXIMUM NUMBER OF FILES TO BE MERGED ='$)
ACCEPT 418,FILLIM
C----------------------------------------------------------------- SLIM
416 IF(AT .NE. 'SLIM') GOTO 420
TYPE 419
419 FORMAT(' MAXIMUM NUMBER OF STRUCTURES TO BE RETRIEVED ='$)
ACCEPT 418,STRCLIM
418 FORMAT(I)
C-----------------------------------------------------------------
420 IF(AT .NE. 'FORCE') GOTO 700
TERSE=2
LSYM='*'
SCC=40
GOTO 701
C-----------------------------------------------------------------
700 IF(AT .NE. 'CLEAR') GO TO 20
701 DO 600 I1=1,4
SST(I1)=1
600 SHUNT(I1)=1
SHUNT(5)=1
BNCNT=1
BNINCL(1,1)=0
BNINCL(1,2)=0
LNUMB=0
TERMC=0
INCL=0
DO 21 I1=1,1000
AREQ(I1)=0
STATE(I1)=0
SSTATE(I1)=0
21 CONTINUE
NUMB=0
ATHN=0
C-----------------------------------------------------------------
20 IF(AT .EQ. 'ABOND') CALL ADBOND
IF(AT .EQ. 'ALINK') CALL ADLINK
IF(AT .EQ. 'NUC') CALL NUCLEUS
IF(AT .EQ. 'SBOND') CALL BONDCL
C-----------------------------------------------------------------
IF(AT .NE. 'ATOM') GO TO 1221
TYPE 111,(ATAS(I3),I3=1,106)
111 FORMAT(1X,10A3)
TYPE 1111
1111 FORMAT(' ')
C-----------------------------------------------------------------
1221 IF(AT .NE. 'SCALE') GO TO 532
SCC=100-SCC
I1=1
IF(SCC .EQ. 60) I1=2
TYPE 533,I1
533 FORMAT(' SCALE NOW ',1I1/)
C-----------------------------------------------------------------
532 IF(AT .NE. 'TERMA') GO TO 222
DO 223 I1=1,10,2
IF(ATAR(I1) .EQ. 0) GO TO 222
IF(TERMC .EQ. 0) GO TO 229
DO 224 I2=1,TERMC
IF(ATAR(I1) .EQ. TERMAT(I2)) GO TO 226
224 CONTINUE
229 CONTINUE
TERMC=TERMC+1
TERMAT(TERMC)=ATAR(I1)
TERMV(TERMC)=ATAR(I1+1)
GO TO 223
226 CONTINUE
TERMV(I2)=ATAR(I1+1)
223 CONTINUE
TYPE 228,(TERMAT(I1),I1=1,TERMC)
228 FORMAT(' TERMINATING ATOMS FOR ATOM BY ATOM COMPARE'/1X,20I3)
TYPE 227,(TERMV(I1),I1=1,TERMC)
227 FORMAT(1X,20I3)
C-----------------------------------------------------------------
222 IF(AT .NE. 'INCLA') GO TO 322
TYPE 323
323 FORMAT(' ATOM TYPES (4A2) ='$)
ACCEPT 324,(TEMP(I1),I1=1,4)
324 FORMAT(4A2)
3244 FORMAT(1X,1A2,',',1A2,',',1A2,',',1A2/)
DO 325 I1=1,10
IF(ATAR(I1) .EQ. 0) GO TO 3322
IF(INCL .EQ. 0) GO TO 327
DO 326 I2=1,INCL
IF(INCLA(I2) .EQ. ATAR(I1)) GO TO 328
326 CONTINUE
327 CONTINUE
INCL=INCL+1
INCLA(INCL)=ATAR(I1)
DO 329 I2=1,4
INCLT(INCL,I2)=TEMP(I2)
329 CONTINUE
GO TO 325
328 CONTINUE
DO 330 I3=1,4
INCLT(I2,I3)=TEMP(I3)
330 CONTINUE
325 CONTINUE
3322 CONTINUE
TYPE 332
TYPE 331,(INCLA(I2),(INCLT(I2,I3),I3=1,4),
1 I2=1,INCL)
332 FORMAT(' ATOM INCLUSION CLASSES FOR ATOM BY ATOM COMPARE')
331 FORMAT(1X,1I2,4A3)
C--------------------------------------------------- NO MORE
322 CONTINUE
END
SUBROUTINE GSCHAR (ICA)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /IO/ CID,COD,E2CID,ICNT,BOD
COMMON /CGSC/ ATAR(80)
TYPE 102
102 FORMAT(' *',$)
ACCEPT 101,ICA,(ATAR(I1),I1=1,10)
101 FORMAT(1A5,1X,10I)
DO 10 I11=10,0,-1
IF(ATAR(I11) .NE. 0) GO TO 11
10 CONTINUE
11 CONTINUE
END
SUBROUTINE ADLINK
C-------------------------------------------------------------------------------
IMPLICIT INTEGER(A-Z)
COMMON /CGSC/ ATAR(80)
COMMON /CASA/ NUMB,AR(10,100)
DO 555 I5=1,9,3
FST=ATAR(I5)
NUM=ATAR(I5+1)
LEN=ATAR(I5+2)
IF(NUM .EQ. 0) GOTO 556
DO 21 I1=5,10
IF(AR(I1,FST) .EQ. NUM) GO TO 555
IF(AR(I1,FST) .EQ. 0) GO TO 23
21 CONTINUE
23 CONTINUE
AR(I1,FST)=NUMB+1
DO 24 I3=5,10
IF(AR(I3,NUM) .EQ. FST) GO TO 555
IF(AR(I3,NUM) .EQ. 0) GO TO 26
24 CONTINUE
26 CONTINUE
90 CONTINUE
IF(LEN .EQ. 0) GO TO 555
AR(I1,FST)=NUMB+1
I7=NUMB+1
DO 550 I6=1,LEN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
550 CONTINUE
AR(5,I7)=FST
AR(6,NUMB)=NUM
AR(I3,NUM)=NUMB
555 CONTINUE
556 CONTINUE
CALL NMORGAN
END
SUBROUTINE ADBOND
C-------------------------------------------------------------------------------
IMPLICIT INTEGER(A-Z)
COMMON /CGSC/ ATAR(80)
COMMON /CASA/ NUMB,AR(10,100)
DO 555 I5=1,10,2
FST=ATAR(I5)
NUM=ATAR(I5+1)
IF(NUM .EQ. 0) GOTO 556
DO 21 I1=5,10
IF(AR(I1,FST) .EQ. NUM) GO TO 90
IF(AR(I1,FST) .EQ. 0) GO TO 23
21 CONTINUE
23 CONTINUE
AR(I1,FST)=NUM
DO 24 I3=5,10
IF(AR(I3,NUM) .EQ. FST) GO TO 90
IF(AR(I3,NUM) .EQ. 0) GO TO 26
24 CONTINUE
26 CONTINUE
AR(I3,NUM)=FST
90 CONTINUE
555 CONTINUE
556 CONTINUE
CALL NMORGAN
END
SUBROUTINE BONDCL
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
DATA FSTSW /0/
COMMON /IO/ CID,COD
COMMON /CGSC/ ATAR(80)
COMMON /CASA/ NUMB,AR(10,100)
COMMON /CBNDST/ BNAM(15)
DATA (BNAM(I1),I1=1,15)/
1 'RS','RD','RT','TR','CS','CD','CT','TC',
1 'RA','R','C','S','D','T','A'/
COMMON /CLASS/ BNCNT,BNINCL(50,3)
90 CONTINUE
101 FORMAT(' RS=RING SINGLE RD=RING DOUBLE'
1 ' RT=RING TRIPLE TR=RING TAUT'/' CS=CHAIN SINGLE'
1 ' CD=CHAIN DOUBLE CT=CHAIN TRIPLE TC=CHAIN TAUT'/
1 ' RA=RING ALTERNATING R=RING ONLY C=CHAIN ONLY'/
1 ' S=ANY SINGLE D=ANY DOUBLE T=ANY TRIPLE A=ANY BOND'/)
TYPE 102
102 FORMAT(' SELECT BOND STATE')
IF(FSTSW .GE. 1) GO TO 4646
FSTSW=FSTSW+1
TYPE 101
GO TO 11
4646 CONTINUE
TYPE 4647
4647 FORMAT(' CS CD CT TC'/' RS RD RT TR RA'/
1 ' R C S D T A'/)
11 CONTINUE
ACCEPT 106,CA
106 FORMAT(1A5)
DO 12 I1=1,15
IF(BNAM(I1) .EQ. CA) GO TO 13
12 CONTINUE
13 CONTINUE
7576 CONTINUE
DO 550 I5=1,10,2
N1=ATAR(I5)
N2=ATAR(I5+1)
IF(N1 .EQ. 0) RETURN
DO 58 I9=1,BNCNT-1
IF((BNINCL(I9,1) .EQ. N1 .AND. BNINCL(I9,2) .EQ. N2)
1 .OR. (BNINCL(I9,1) .EQ. N2 .AND. BNINCL(I9,2) .EQ. N1))
1 GO TO 51
58 CONTINUE
I9=BNCNT
BNCNT=BNCNT+1
51 CONTINUE
BNINCL(I9,1)=N1
BNINCL(I9,2)=N2
BNINCL(I9,3)=I1
550 CONTINUE
END
SUBROUTINE ALTBOND (SKIP,BOND)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /IO/ CID,COD
COMMON /CGSC/ ATAR(80)
COMMON /CASA/ NUMB,AR(10,100)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
COMMON /PUSH/ DUM(600),MAR(20)
DO 550 I5=1,10,2
M1=ATAR(I5)
M2=ATAR(I5+1)
IF(M1 .EQ. 0) RETURN
CALL ALTRING (M1,M2)
DO 560 I6=1,6,SKIP
N1=MAR(I6)
N2=MAR(I6+1)
IF(I6 .EQ. 6) N2=MAR(1)
DO 58 I9=1,BNCNT-1
IF((BNINCL(I9,1) .EQ. N1 .AND. BNINCL(I9,2) .EQ. N2)
1 .OR. (BNINCL(I9,1) .EQ. N2 .AND. BNINCL(I9,2) .EQ. N1))
1 GO TO 51
58 CONTINUE
I9=BNCNT
BNCNT=BNCNT+1
51 CONTINUE
BNINCL(I9,1)=N1
BNINCL(I9,2)=N2
BNINCL(I9,3)=BOND
560 CONTINUE
550 CONTINUE
END
SUBROUTINE ALTRING (M1,M2)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(1000)
COMMON /RNGCAR/ RNGCAR(90)
COMMON /CPROC/ GRC,RNGC
COMMON /PUSH/ PUSH1(500),RNGST(100),SMRAR(90),TEMAR(90)
IC=M1
ICC=(M1-1)*10
ORC=1
BRATC=0
PC=5
10 CONTINUE
PUSH1(1)=IC
PUSH1(5)=ICC
ICL=0
I2=PC+1
IT=1
TEMAR(1)=IC
SMR=1000
400 CONTINUE
C BEGIN NEIGHBOR SEARCH
ID=4
200 CONTINUE
ID=ID+1
I31=AR(ID+ICC)
IF(I31 .EQ. 0 )GO TO 500
IF(ID .GT. 10) GO TO 500
IF(I31 .EQ. ICL) GO TO 200
IF(IC .EQ. M1 .AND. I31 .NE. M2) GO TO 200
300 CONTINUE
DO 301 I3=1,IT
IF(TEMAR(I3) .EQ. I31) GO TO 302
301 CONTINUE
C THIS ATOM NOT YET ON THE LIST
IT=IT+1
TEMAR(IT)=I31
PUSH1(I2)=IC
PUSH1(I2+1)=ID
PUSH1(I2+2)=IT-1
PUSH1(I2+3)=ICL
PUSH1(I2+4)=ICC
I2=I2+PC
ICL=IC
IC=I31
ICC=(IC-1)*10
GO TO 400
302 CONTINUE
IF(I3 .NE. 1) GO TO 200
C LOOP BACK TO STARTING POINT
IF(IT .GE. SMR) GO TO 200
C RING IS SMALLER SAVE IT
SMR=IT
DO 304 I32=1,IT
SMRAR(I32)=TEMAR(I32)
304 CONTINUE
GO TO 200
500 CONTINUE
C POP THE STACK
I2=I2-PC
IC=PUSH1(I2)
ID=PUSH1(I2+1)
IT=PUSH1(I2+2)
ICL=PUSH1(I2+3)
ICC=PUSH1(I2+4)
IF(I2 .NE. 1) GO TO 200
600 CONTINUE
C POPPED BACK TO BASE
11 CONTINUE
END
SUBROUTINE EQCL (N1,N2,SYM)
C-------------------------------------------------------------------------------
C A TOAD WHICH TOUTS FOR BONDCL
IMPLICIT INTEGER (A-Z)
COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
DATA FSTSW /0/
DIMENSION BONDMAP(15)
DATA (BONDMAP(I1),I1=1,15)/
1 '*','+','#','%','*','+','#','%',
1 '.','*','*','*','+','#','$'/
COMMON /CBNDST/ BNDST(14)
COMMON /CASA/ NUMB,AR(10,100)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
IF(BNCNT .EQ. 1) RETURN
IF(FSTSW .EQ. 1) GO TO 50
FSTSW=1
BONDMAP(1)=PSINGLE
BONDMAP(2)=PDOUBLE
BONDMAP(3)=PTRIPLE
BONDMAP(4)=PTAUT
BONDMAP(5)=PSINGLE
BONDMAP(6)=PDOUBLE
BONDMAP(7)=PTRIPLE
BONDMAP(8)=PTAUT
BONDMAP(9)=PALT
50 CONTINUE
DO 60 I1=1,BNCNT-1
IF(BNINCL(I1,1) .EQ. N1 .AND. BNINCL(I1,2)
1 .EQ. N2) GO TO 61
IF(BNINCL(I1,1) .EQ. N2 .AND.BNINCL(I1,2)
1 .EQ. N1) GO TO 61
60 CONTINUE
RETURN
61 CONTINUE
I2=BNINCL(I1,3)
SYM=BONDMAP(I2)
END
C DOEASY: MAIN LOOP IS HERE
SUBROUTINE DOEASY
IMPLICIT INTEGER (A-Z)
COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
COMMON /CNEWHLD/ SSTATE(1000)
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CFFXX/ FN,IEXT,HFILEN(40)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20),INCL,INCLA(20),INCLT(20,4)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
1 ,LSYM,DELTA
COMMON /CGSC/ ATAR(80)
COMMON /CACL/ EKC,UPB,WC,ICC,CARCL(1000)
COMMON /CMI/ DUMCR(106),DUMAT(106),MATX(40),CONX(40),
1 CONXT(6),ATXT(6),ATX(6,40),RCBX(6,40),CC,AACNT(40)
1 ,REGA(10),P(25),LEVEL(12)
COMMON /CSTRC/ STRCNT(11)
COMMON /CAUTO/ IAUTO,IPROP,ICSTAR,IPREVF,IPREVR
COMMON /CL4INT/ ISOCNT
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /CREST/ LNUMB,STATE (1000)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
COMMON /IO/ CID,COD
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
EQUIVALENCE (PROBE,SW)
C-----------------------------------------------------------------
TERSE=1
TERMC=0
INCL=0
ATHN=0
DELTA=1
BENDARM=2
LNUMB=0
NUMB=0
DO 66621 I1=1,1000
AREQ(I1)=0
66621 CONTINUE
20 CALL CHOICE (AT)
DO 7183 I1=1,1000
STATE(I1)=AREQ(I1)
7183 CONTINUE
LNUMB=NUMB
C-----------------------------------------------------------------
IF(NUMB .EQ. 0 .OR. AT .NE. 'D') GO TO 21
DO 86 I1=1,1000
SSTATE(I1)=AREQ(I1)
86 CONTINUE
LLNUMB=NUMB
CALL CSRG (2)
C MODE 0 FOR NO NUMBERS IN GMOL MODE 2 FOR NUMBERS
CALL GMOL (0)
QFLG=0
GOTO 20
C-----------------------------------------------------------------
21 IF(NUMB .EQ. 0 .OR. AT .NE. 'Q') GO TO 921
DO 986 I1=1,1000
SSTATE(I1)=AREQ(I1)
986 CONTINUE
LLNUMB=NUMB
CALL CSRG (2)
C MODE 0 FOR NO NUMBERS IN GMOL MODE 2 FOR NUMBERS
CALL GMOL (0)
GOTO 20
C-----------------------------------------------------------------
921 ATHN=NUMB
IF(AT .NE. 'REST') GO TO 80
7175 CONTINUE
C RESTORE THE STRUCTURE TO THE PREVIOUS STATE
QFLG=0
DO 85 I1=1,1000
AREQ(I1)=SSTATE(I1)
85 CONTINUE
NUMB=LLNUMB
ATHN=LLNUMB
GO TO 20
C-----------------------------------------------------------------
80 CONTINUE
230 CONTINUE
IF(AT .NE. 'DATOM') GOTO 5111
CALL DELATOM
GOTO 20
C-----------------------------------------------------------------
5111 CONTINUE
IF(AT .NE. 'MORGA') GOTO 5112
CALL NMORGAN
GOTO 20
C-----------------------------------------------------------------
5112 CONTINUE
IF(AT .EQ. 'ALTBD') CALL ALTBOND (1,9)
IF(AT .EQ. 'WISBD') CALL ALTBOND (2,6)
C-----------------------------------------------------------------
IF(AT .NE. 'AATOM') GO TO 660
DO 3232 I2=1,10,2
I3=ATAR(I2)
I4=ATAR(I2+1)
IF(I3 .EQ. 0 .OR. I4 .EQ. 0) GO TO 20
NUMB=NUMB+1
DO 661 I1=5,10
IF(AR(I1,I3) .EQ. I4) GO TO 662
661 CONTINUE
GO TO 20
662 CONTINUE
AR(I1,I3)=NUMB
DO 663 I1=5,10
IF(AR(I1,I4) .EQ. I3) GO TO 664
663 CONTINUE
GO TO 20
664 CONTINUE
AR(I1,I4)=NUMB
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=I3
AR(6,NUMB)=I4
3232 CONTINUE
GO TO 20
C-----------------------------------------------------------------
660 CONTINUE
IF(AT .NE. 'DBOND') GO TO 670
I2=ATAR(1)
I3=ATAR(2)
IF(I2 .EQ. 0 .OR. I3 .EQ. 0) GOTO 20
DO 671 I1=5,10
IF(AR(I1,I2) .EQ. I3) GO TO 672
671 CONTINUE
672 CONTINUE
I4=I1
DO 673 I5=I1+1,10
AR(I4,I2)=AR(I5,I2)
I4=I4+1
AR(I5,I2)=0
673 CONTINUE
DO 674 I1=5,10
IF(AR(I1,I3) .EQ. I2) GO TO 675
674 CONTINUE
675 CONTINUE
I4=I1
DO 676 I5=I1+1,10
AR(I4,I3)=AR(I5,I3)
I4=I4+1
AR(I5,I3)=0
676 CONTINUE
GO TO 20
C-----------------------------------------------------------------
670 CONTINUE
IF(AT .NE. 'SATOM') GO TO 200
TYPE 211
211 FORMAT(' ATOM TYPE ='$)
ACCEPT 212,CA
212 FORMAT(1A5)
DO 210 I1=1,10
I2=ATAR(I1)
IF(I2 .EQ. 0) GO TO 20
IF(I2 .GT. NUMB) GO TO 210
AR(2,I2)=CA
IF(CA .EQ. 'C') AR(2,I2)=0
210 CONTINUE
GO TO 20
C-----------------------------------------------------------------
200 CONTINUE
IF(AT .NE. 'SPIRO') GO TO 6060
DO 6061 I2=1,10,2
STNUM=ATAR(I2)
FINNUM=STNUM
EXTN=ATAR(I2+1)
IF(STNUM .EQ. 0 .OR. FINNUM .EQ. 0) GO TO 20
DO 6201 I1=5,10
IF(AR(I1,STNUM) .EQ. 0) GO TO 6202
6201 CONTINUE
6202 CONTINUE
AR(I1,STNUM)=NUMB+1
I3=NUMB+1
DO 6203 I1=1,EXTN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
6203 CONTINUE
AR(5,I3)=STNUM
AR(6,NUMB)=FINNUM
DO 6204 I1=5,10
IF(AR(I1,FINNUM) .EQ. 0) GO TO 6205
6204 CONTINUE
6205 CONTINUE
AR(I1,FINNUM)=NUMB
6061 CONTINUE
GO TO 20
C-----------------------------------------------------------------
6060 CONTINUE
IF(AT .NE. 'ARING') GO TO 90
DO 2040 I2=1,10,2
STNUM=ATAR(I2)
FINNUM=ATAR(I2+1)
IF(STNUM .EQ. 0 .OR. FINNUM .EQ. 0) GO TO 20
DO 201 I1=5,10
IF(AR(I1,STNUM) .EQ. 0) GO TO 202
201 CONTINUE
202 CONTINUE
IF(STNUM .NE. FINNUM) GO TO 7060
EXTN=5
GO TO 300
7060 CONTINUE
CALL MINDIS (AR,STNUM,FINNUM,DIF)
C IF THE TWO NODES ARE IN DIFFERENT STRUCTURES JUST BOND THEM TOGETHER
IF(DIF .EQ. 0) GO TO 303
EXTN=6-DIF
IF(EXTN .NE. 0) GO TO 300
303 CONTINUE
C JUST ADD BOND TO FORM RING
AR(I1,STNUM)=FINNUM
DO 301 I1=5,10
IF(AR(I1,FINNUM) .EQ. 0) GO TO 302
301 CONTINUE
302 CONTINUE
AR(I1,FINNUM)=STNUM
GO TO 2040
300 CONTINUE
AR(I1,STNUM)=NUMB+1
I3=NUMB+1
DO 203 I1=1,EXTN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
203 CONTINUE
AR(5,I3)=STNUM
AR(6,NUMB)=FINNUM
DO 204 I1=5,10
IF(AR(I1,FINNUM) .EQ. 0) GO TO 205
204 CONTINUE
205 CONTINUE
AR(I1,FINNUM)=NUMB
2040 CONTINUE
GO TO 20
C-----------------------------------------------------------------
90 CONTINUE
IF(AT .NE. 'CRING') GO TO 590
DO 5040 I2=1,10,2
STNUM=ATAR(I2)
EXTN=ATAR(I2+1)
IF(EXTN .EQ. 0) EXTN=6
IF(STNUM .EQ. 0) GO TO 20
DO 509 I1=5,10
IF(AR(I1,STNUM) .EQ. 0) GO TO 508
509 CONTINUE
508 CONTINUE
AR(I1,STNUM)=NUMB+1
I3=NUMB+1
EXTN=EXTN-1
DO 503 I1=1,EXTN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
503 CONTINUE
AR(5,I3)=STNUM
AR(6,NUMB)=STNUM
DO 504 I1=5,10
IF(AR(I1,STNUM) .EQ. 0) GO TO 505
504 CONTINUE
505 CONTINUE
AR(I1,STNUM)=NUMB
5040 CONTINUE
GO TO 20
C-----------------------------------------------------------------
590 CONTINUE
IF(AT .NE. 'ABRAN') GO TO 240
DO 2050 I2=1,10,2
STNUM=ATAR(I2)
NN=ATAR(I2+1)
IF(STNUM .EQ. 0) GO TO 20
I3=NUMB+1
DO 242 I1=1,NN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
242 CONTINUE
AR(5,I3)=STNUM
AR(6,NUMB)=0
DO 243 I1=5,10
IF(AR(I1,STNUM) .EQ. 0) GO TO 244
243 CONTINUE
244 CONTINUE
AR(I1,STNUM)=I3
2050 CONTINUE
GO TO 20
C-----------------------------------------------------------------
240 CONTINUE
IF(AT .NE. 'CHAIN') GO TO 260
NN=ATAR(1)
I3=NUMB+1
DO 262 I1=1,NN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
262 CONTINUE
AR(5,I3)=AR(6,I3)
AR(6,I3)=0
AR(6,NUMB)=0
GO TO 20
C-----------------------------------------------------------------
260 CONTINUE
IF(AT .NE. 'RING') GO TO 261
C LOOP CLOSES PUT IN RING
I3=NUMB+1
DO 221 I1=1,6
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
221 CONTINUE
AR(5,I3)=NUMB
AR(6,NUMB)=I3
GO TO 20
C-----------------------------------------------------------------
261 CONTINUE
IF(AT .NE. 'C') GOTO 9264
DO 9265 I1=1,NUMB
DO 9266 I2=10,5,-1
IF(AR(I2,I1) .NE. 0) GOTO 9267
9266 CONTINUE
9267 CONTINUE
I4=AR(2,I1)
IF(I4 .EQ. 0) I4='C'
TYPE 9268,I1,I4,(AR(I3,I1),I3=5,I2)
9268 FORMAT(1I3,1X,1A2,1X,6I3)
9265 CONTINUE
GOTO 20
C-----------------------------------------------------------------
9264 CONTINUE
REREAD 9262,IBIB
9262 FORMAT(1A3)
GOTO 20
END
SUBROUTINE DELATOM
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CGSC/ ATAR(80)
COMMON /CASA/ NUMB,AR(10,100),BR(10,100)
DIMENSION AREQ(10),BREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
EQUIVALENCE (BREQ(1),BR(1,1))
DO 90 I9=1,10
NUM=ATAR(I9)
IF(NUM .EQ. 0) GO TO 91
DO 10 I1=5,10
IF(AR(I1,NUM) .EQ. 0) GO TO 11
10 CONTINUE
11 CONTINUE
I1=I1-5
IF(I1 .EQ. 2) GO TO 30
IF(I1 .NE. 1) GO TO 90
C ONE NEIGHBOR NODE DELETE IT
I2=AR(5,NUM)
DO 41 I1=5,10
IF(AR(I1,I2) .EQ. NUM) GO TO 42
41 CONTINUE
42 CONTINUE
AR(5,NUM)=0
AR(I1,I2)=0
IF(NUM .EQ. NUMB) NUMB=NUMB-1
AR(1,NUM)=0
AR(2,NUM)=0
GO TO 90
30 CONTINUE
I2=AR(5,NUM)
I4=AR(6,NUM)
DO 20 I3=5,10
IF(AR(I3,I2) .EQ. NUM) GO TO 21
20 CONTINUE
21 CONTINUE
AR(I3,I2)=I4
DO 25 I3=5,10
IF(AR(I3,I4) .EQ. NUM) GO TO 26
25 CONTINUE
26 CONTINUE
AR(I3,I4)=I2
AR(1,NUM)=0
AR(2,NUM)=0
90 CONTINUE
91 CONTINUE
DO 105 I3=1,NUMB
IF(AR(1,I3) .NE. 0) GOTO 106
105 CONTINUE
106 CONTINUE
CALL CONTIG (AR,BR,I3,NUMB)
I3=NUMB*10
DO 310 I1=1,I3
AREQ(I1)=BREQ(I1)
310 CONTINUE
END
SUBROUTINE CONTIG (FROMAR,TOAR,NUM,CNT)
C-------------------------------------------------------------------------------
C WORD 3 OF EACH ATOM IS USED TO DENOTE WHETHER RING OR BRANCH
C 1 IS BRANCH 0 IS RING
IMPLICIT INTEGER (A-Z)
DIMENSION FROMAR(10,100),TOAR(10,100)
COMMON /MARK/ CT(20),MK(100)
CT(1)=NUM
CT(2)=0
CTC=2
DO 9 I1=1,100
MK(I1)=0
9 CONTINUE
20 CONTINUE
DO 10 I1=1,20
I4=CT(I1)
IF(I4 .EQ. 0) GO TO 50
DO 30 I2=5,10
I3=FROMAR(I2,I4)
IF(I3 .EQ. 0) GO TO 30
IF(MK(I3) .NE. 0) GO TO 30
MK(I3)=1
CT(CTC)=I3
CTC=CTC+1
IF(CTC .GE. 21) CTC=1
CT(CTC)=0
30 CONTINUE
10 CONTINUE
GO TO 20
50 CONTINUE
CNT=0
DO 60 I1=1,100
IF(MK(I1) .EQ. 0) GO TO 60
CNT=CNT+1
MK(I1)=CNT
60 CONTINUE
ICNT=0
DO 70 I1=1,100
IF(MK(I1) .EQ. 0) GO TO 70
ICNT=ICNT+1
TOAR(1,ICNT)=MK(I1)
TOAR(2,ICNT)=FROMAR(2,I1)
TOAR(3,ICNT)=FROMAR(3,I1)
TOAR(4,ICNT)=0
I6=5
DO 71 I2=5,10
I3=FROMAR(I2,I1)
TOAR(I2,ICNT)=0
IF(I3 .EQ. 0) GO TO 71
IF(MK(I3) .EQ. 0) GO TO 71
TOAR(I6,ICNT)=MK(I3)
I6=I6+1
71 CONTINUE
70 CONTINUE
END
SUBROUTINE MINDIS (AR,NUM,MUM,MIN)
C-------------------------------------------------------------------------------
C
C FINDS THE MINIMUM DISTANCE BETWEEN TWO NODES NUM AND MUM
C
C IN PUSH1 WD1=ATOM POINTER WD2=NEIGHBOR WD3=NEXT PLACE TO STORE ATOM
C IN TEMAR
IMPLICIT INTEGER (A-Z)
DIMENSION AR(10,50)
COMMON /PUSH/ PUSH1(500),TEMAR(90)
C TRY TO SHORT CIRCUIT MINDIS SEE IF MUM IS FIRST NEIGHBOR OF NUM
DO 700 IC=5,10
IF(AR(IC,NUM) .NE. MUM) GO TO 700
C MUM IS FIRST NEIGHBOR
MIN=2
RETURN
700 CONTINUE
IC=NUM
ORC=1
BRATC=0
PC=4
10 CONTINUE
PUSH1(1)=IC
ICL=0
I2=PC+1
IT=1
TEMAR(1)=IC
MIN=10000
400 CONTINUE
C BEGIN NEIGHBOR SEARCH
ID=4
200 CONTINUE
ID=ID+1
I31=AR(ID,IC)
IF(I31 .EQ. 0 )GO TO 500
IF(ID .GT. 10) GO TO 500
IF(I31 .EQ. ICL) GO TO 200
IF(I31 .EQ. MUM) GO TO 302
300 CONTINUE
DO 301 I3=1,IT
IF(TEMAR(I3) .EQ. I31) GO TO 200
301 CONTINUE
C THIS ATOM NOT YET ON THE LIST
IT=IT+1
TEMAR(IT)=I31
PUSH1(I2)=IC
PUSH1(I2+1)=ID
PUSH1(I2+2)=IT-1
PUSH1(I2+3)=ICL
I2=I2+PC
ICL=IC
IC=I31
GO TO 400
302 CONTINUE
C FOUND A SMALLER DISTANCE BETWEEN THE TWO NODES
IF(IT .GE. MIN) GO TO 200
C DISTANCE IS SMALLER SAVE IT
MIN=IT
GO TO 200
500 CONTINUE
C POP THE STACK
I2=I2-PC
IC=PUSH1(I2)
ID=PUSH1(I2+1)
IT=PUSH1(I2+2)
ICL=PUSH1(I2+3)
IF(I2 .NE. 1) GO TO 200
600 CONTINUE
C POPPED BACK TO BASE
MIN=MIN+1
END
SUBROUTINE NUCLEUS
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /IO/ CID,COD
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
COMMON /CASA/ NUMB,AR(10,100)
COMMON /CGSC/ ATAR(80)
TYPE 101
101 FORMAT('+*'$)
ACCEPT 102,(ATAR(I1),I1=1,20)
1022 FORMAT(1X,20A1)
102 FORMAT(20A1)
DO 10 I1=1,20
I2=ATAR(I1)
IF(I2 .EQ. ' ') GO TO 11
IF(I2 .NE. 'U') GO TO 20
ILL=IUL
IUL=IUL-1
GO TO 10
20 CONTINUE
IF(I2 .NE.'D') GO TO 21
IUL=ILL
ILL=ILL+1
GO TO 10
21 CONTINUE
DECODE (1,103,I2)IR
103 FORMAT(1I1)
IF(IR .LT. 3 .OR. IR .GT. 7) GO TO 10
IF(I1 .NE. 1) GO TO 30
I4=NUMB+1
DO 221 I3=1,IR
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
221 CONTINUE
AR(5,I4)=NUMB
AR(6,NUMB)=I4
IUL=I4
ILL=NUMB
GO TO 10
30 CONTINUE
DO 31 I3=5,10
IF(AR(I3,IUL) .EQ. 0) GO TO 32
31 CONTINUE
32 CONTINUE
AR(I3,IUL)=NUMB+1
EXTN=IR-2
I4=NUMB+1
DO 40 I3=1,EXTN
NUMB=NUMB+1
AR(1,NUMB)=NUMB
AR(2,NUMB)=0
AR(5,NUMB)=NUMB-1
AR(6,NUMB)=NUMB+1
40 CONTINUE
AR(5,I4)=IUL
AR(6,NUMB)=ILL
DO 51 I3=5,10
IF(AR(I3,ILL) .EQ. 0) GO TO 52
51 CONTINUE
52 CONTINUE
AR(I3,ILL)=NUMB
IUL=I4+(EXTN/2)-1
ILL=I4+(EXTN/2)
10 CONTINUE
11 CONTINUE
END
SUBROUTINE GMOL (II)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CREGNO/ REGNO
COMMON /IO/ CID,COD,E2CID
COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
DATA PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
1 /'*','+','#','.','%'/
COMMON /CMIRSUP/ MIRSUP
DATA MIRSUP /0/
DATA ERCNT /0/
COMMON /CACL/ DUMM(4),BND(10,100)
COMMON /CATAS/ ATAS(106)
COMMON /MD/ MDX,MDY
COMMON /CASA/ NUMB,AR(10,100),ARP(100,1)
DATA DCON /20/
DATA DOFF /25/
DIMENSION PT(5)
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CIOMNI/ IOMNI,IOMDEV
IF(E2CNT .EQ. 0 .OR. E2SW .EQ. 1) GO TO 300
ERCNT=ERCNT+1
RETURN
300 CONTINUE
CALL CLRAR
MINX=10000
MINY=10000
MAXX=0
MAXY=0
DO 80 I1=1,NUMB
I2=AR(3,I1)
I3=AR(4,I1)
IF(I2 .GT. MAXX)MAXX=I2
IF(I2 .LT. MINX) MINX=I2
IF(I3 .GT. MAXY) MAXY=I3
IF(I3 .LT. MINY) MINY=I3
80 CONTINUE
IF(((MAXY-MINY)-(MAXX-MINX)) .LT. 10) GO TO 81
IF(MIRSUP .EQ. 0) CALL MIRROR
81 CONTINUE
DO 10 I1=1,NUMB
IF(AR(3,I1) .EQ. 0 .OR. AR(4,I1) .EQ. 0) GO TO 11
I2=(AR(3,I1)/DCON)+DOFF
I3=(AR(4,I1)/DCON)+DOFF
I99=AR(2,I1)
IF(II .NE. 2) GO TO 70
CALL QPACN (I99,PT,5)
ARP(I2,I3)=PT(1)
IF(PT(2) .NE. ' ') ARP(I2+1,I3)=PT(2)
GO TO 71
70 CONTINUE
IF(I99 .EQ. 0) I99=' '
ENCODE (5,101,PTT) I1,I99
101 FORMAT(1I2,1A2)
CALL QPACN (PTT,PT,5)
I21=1
IF(PT(1) .EQ. ' ') I21=2
I22=5
IF(PT(4) .EQ. ' ') I22=3
IF(PT(3) .EQ. ' ') I22=2
DO 90 I11=I21,I22
ARP(I2+I11-I21,I3)=PT(I11)
90 CONTINUE
71 CONTINUE
DO 20 I4=5,10
I55=AR(I4,I1)
IF(I55 .EQ. 0) GO TO 60
IF(I55 .LT. I1) GO TO 20
I10=(AR(3,I55)/DCON)+DOFF
I11=(AR(4,I55)/DCON)+DOFF
SYM=PSINGLE
IF(II .EQ. 2) GO TO 510
CALL EQCL (I1,I55,SYM)
GO TO 50
510 CONTINUE
IB=BND(I4,I1)
IF(IB .EQ. 2 .OR. IB .EQ. 6) SYM=PDOUBLE
IF(IB .EQ. 3 .OR. IB .EQ. 7) SYM=PTRIPLE
IF(IB .EQ. 4 .OR. IB .EQ. 8) SYM=PTAUT
IF(IB .EQ. 9) SYM=PALT
50 CONTINUE
CALL LINE (I2,I3,I10,I11,SYM)
20 CONTINUE
60 CONTINUE
10 CONTINUE
CALL GWOUT
RETURN
11 CONTINUE
ERCNT=ERCNT+1
END
SUBROUTINE MIRROR
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,MOLLY(10,100)
DO 31 I2=1,NUMB
IX=MOLLY(3,I2)
IY=MOLLY(4,I2)
MOLLY(3,I2)=IY
MOLLY(4,I2)=IX
31 CONTINUE
END
SUBROUTINE LINE (X1,Y1,X2,Y2,SYM)
C-------------------------------------------------------------------------------
C DRAW ANY HORIZ,VERT OR DIAG LINE
IMPLICIT INTEGER (A-Z)
COMMON /CVTBAR/ VTB,DFSW
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
COMMON /CASA/ DDD(1001),AR(100,1)
COMMON /MD/ MDX,MDY
DATA MDX,MDY /100,100/
DATA BKSL,VTBAR /"560000000000,"760000000000/
IF(X1 .EQ. 0 .OR. Y1 .EQ. 0 .OR. X2 .EQ. 0 .OR. Y2 .EQ. 0)
1 CALL WO ('LINE')
IF(Y1 .EQ. Y2) GO TO 10
IF(X1 .NE. X2) GO TO 20
IF(SYM .EQ. LSYM .AND. VTB .EQ. 1) SYM=VTBAR
IF(SYM .EQ. LSYM .AND. VTB .EQ. 0) SYM='ā'
IF(Y1 .LE. Y2) GO TO 1
TY1=Y2
TY2=Y1
GO TO 2
1 CONTINUE
TY1=Y1
TY2=Y2
2 CONTINUE
DO 30 I1=TY1,TY2
IF(I1 .GT. MDY .OR. I1 .LT. 1) GO TO 30
IF(AR(X1,I1) .NE. ' ') GO TO 30
AR(X1,I1)=SYM
30 CONTINUE
RETURN
20 CONTINUE
I4=IABS(X1-X2) +1
TX1=X1
TY1=Y1
TY2=Y2
IF(X1 .LT. X2) GO TO 21
TX1=X2
TY1=Y2
TY2=Y1
21 CONTINUE
IF(TY1 .GT. TY2) GO TO 22
IF(SYM .EQ. LSYM) SYM='/'
DO 50 I1=1,I4
I6=TX1-1+I1
I7=TY1-1+I1
IF(I7 .GT. TY2) I7=TY2
IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
1 GO TO 50
IF(AR(I6,I7) .NE. ' ') GO TO 50
AR(I6,I7)=SYM
50 CONTINUE
RETURN
22 CONTINUE
IF(SYM .EQ. LSYM) SYM=BKSL
DO 51 I1=1,I4
I6=TX1-1+I1
I7=TY1+1-I1
IF(I7 .LT. TY2) I7=TY2
IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
1 GO TO 51
IF(AR(I6,I7) .NE. ' ') GO TO 51
AR(I6,I7)=SYM
51 CONTINUE
RETURN
10 CONTINUE
IF(SYM .EQ. LSYM) SYM='-'
IF(X1 .LE. X2) GO TO 11
TX1=X2
TX2=X1
GO TO 12
11 CONTINUE
TX1=X1
TX2=X2
12 CONTINUE
DO 40 I1=TX1,TX2
IF(I1 .GT. MDX .OR. I1 .LT. 1) GO TO 40
IF(AR(I1,Y1) .NE. ' ') GO TO 40
AR(I1,Y1)=SYM
40 CONTINUE
END
SUBROUTINE CLRAR
C-------------------------------------------------------------------------------
C CLEAR THE PRINTOUT ARRAY
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ DDDD(1001),AR(10)
COMMON /MD/ MDX,MDY
I2=MDX*MDY
DO 10 I1=1,I2
AR(I1)=' '
10 CONTINUE
END
SUBROUTINE GWOUT
C-------------------------------------------------------------------------------
C WRITES OUT THE GRAPH IMAGE
IMPLICIT INTEGER (A-Z)
DATA I111 /0/
COMMON /CREGNO/ REGNO
COMMON /IO/ CID,COD
COMMON /CASA/ DDDD(1001),AR(100,1)
DIMENSION ARE(1)
EQUIVALENCE (AR(1,1),ARE(1))
COMMON /MD/ MDX,MDY
DATA YLEN /1/
I111=I111+1
XMAX=0
YMAX=0
XMIN=MDX
YMIN=MDY
I12=MDX*MDY
DO 10 I11=1,I12
IF(ARE(I11) .EQ. ' ') GO TO 10
I2=MOD(I11,MDX)
IF(I2 .EQ. 0) I2=MDX
I1=(I11/MDX)+1
IF(I2 .GT. XMAX) XMAX=I2
IF(I2 .LT. XMIN) XMIN=I2
IF(I1 .GT. YMAX) YMAX=I1
IF( I1 .LT. YMIN) YMIN=I1
10 CONTINUE
XMAX=XMAX+YLEN
YMAX=YMAX+YLEN
XMIN=XMIN-YLEN
YMIN=YMIN-YLEN
IF( XMIN .LT. 1 ) XMIN=1
IF(YMIN .LT. 1) YMIN=1
IF(XMAX .GT. MDX) XMAX=MDX
IF(YMAX .GT. MDY) YMAX=MDY
DO 30 I1=YMAX,YMIN,-1
I3=XMAX
DO 31 I4=XMIN,XMAX
IF(AR(I3,I1) .NE. ' ') GO TO 32
I3=I3-1
31 CONTINUE
32 CONTINUE
WRITE(5,101)(AR(I2,I1),I2=XMIN,I3)
DO 40 I47=XMIN,I3
AR(I47,I1)=' '
40 CONTINUE
30 CONTINUE
101 FORMAT(' ',130A1)
END
SUBROUTINE CSRG (MODE)
IMPLICIT INTEGER (A-Z)
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /RECC/ RECCNT,RECLIM
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CDQCS/ DQCSRG
COMMON /CSEQ/ SEQ(100),MSEQ(100)
COMMON /ACARR/ ACAR(80)
COMMON /FRDIR/ FRDIR
COMMON /OTHRING/ ORC,ORING(100)
COMMON /RNGGR/ RNGGR
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100),BNDH(6,100)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
DIMENSION EREQ(10)
EQUIVALENCE (EREQ(1),ER(1,1))
DIMENSION BREQ(10)
EQUIVALENCE (BREQ(1),BR(1,1))
COMMON /STPOS/ STPOS
COMMON /CPOSW/ POSW
COMMON /IO/ CID,COD
DATA COD /1/
COMMON /QSCALE/ SCALE,SCC
DATA SCC /80/
DATA SCALE /60/
DIMENSION RINGT(100)
E2CNT=0
SCALE=SCC
P1LIM=990
P2LIM=1990
P3LIM=290
RECLIM=40
DO 90 I1=1,NUMB
AR(4,I1)=I1
90 CONTINUE
IF(MODE .EQ. 1) CALL NMORGAN
DO 900 I1=1,NUMB
SEQ(I1)=AR(3,I1)
MSEQ(I1)=AR(4,I1)
AR(4,I1)=0
AR(3,I1)=0
DO 91 I2=5,10
BNDH(I2-4,I1)=AR(I2,I1)
91 CONTINUE
900 CONTINUE
I13=NUMB*6
DO 12 I1=1,I13
BREQ(I1)=0
BREQ(I1+600 )=0
BREQ(I1+1200)=0
BREQ(I1+1800)=0
EREQ(I1)=0
12 CONTINUE
AR(3,1)=500
AR(4,1)=500
STPOS=0
FRDIR=0
CALL SAFMAF
CALL ELIMEND
CALL RINGGG (0,RINGT,CRINGT,RET)
CALL BRANCH
DO 1047 I1=1,100
ORING(I1)=0
1047 CONTINUE
ORC=1
DO 92 I1=1,NUMB
AR(1,I1)=I1
DO 93 I2=5,10
AR(I2,I1)=BNDH(I2-4,I1)
93 CONTINUE
92 CONTINUE
END
SUBROUTINE RINGGG (MODE,BRATAR,BRATC,RET)
C-------------------------------------------------------------------------------
C IN PUSH1 WD1=ATOM POINTER WD2=NEIGHBOR WD3=NEXT PLACE TO STORE ATOM
C IN TEMAR
IMPLICIT INTEGER (A-Z)
COMMON /RECC/ RECCNT,RECLIM
DIMENSION BRATAR(10)
COMMON /OTHRING/ ORC,ORING(100)
COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /ARCC/ SMRAR(90),TEMAR(90)
IC=0
ORC=1
BRATC=0
IF(MODE .NE. 0) IC=MODE-1
PC=4
10 CONTINUE
IC=IC+1
IF(IC .GT. NUMB) GO TO 11
IF(AR(1,IC) .GT. 100) GO TO 10
PUSH1(1)=IC
ICL=0
I2=PC+1
IT=1
TEMAR(1)=IC
SMR=1000
400 CONTINUE
C BEGIN NEIGHBOR SEARCH
ID=4
200 CONTINUE
ID=ID+1
I31=AR(ID,IC)
IF(I31 .GT. 100) GO TO 200
IF(I31 .EQ. 0 )GO TO 500
IF(ID .GT. 10) GO TO 500
IF(I31 .EQ. ICL) GO TO 200
300 CONTINUE
DO 301 I3=1,IT
IF(TEMAR(I3) .EQ. I31) GO TO 302
301 CONTINUE
C THIS ATOM NOT YET ON THE LIST
IT=IT+1
TEMAR(IT)=I31
PUSH1(I2)=IC
PUSH1(I2+1)=ID
PUSH1(I2+2)=IT-1
PUSH1(I2+3)=ICL
I2=I2+PC
IF(I2 .LE. P1LIM) GO TO 5051
TYPE 5052
5052 FORMAT(' PUSH1 OVERFLOW'/)
RECCNT=1000000
RETURN
5051 CONTINUE
ICL=IC
IC=I31
GO TO 400
302 CONTINUE
IF(I3 .NE. 1) GO TO 200
C LOOP BACK TO STARTING POINT
IF(IT .GE. SMR) GO TO 200
C THE PROGRAM CAN ONLY HANDLEUP TO 7 MEMBERED RINGS
C ABORT ALL LARGER RINGS
IF(IT .GT. 7) GO TO 200
C SEE IF ANY ATOM IN THIS RING IS NOT POSITIONED
DO 950 I95=1,IT
I96=TEMAR(I95)
IF(AR(3,I96) .EQ. 0) GO TO 951
950 CONTINUE
C ALL ATOMS POSITIONED
GO TO 200
951 CONTINUE
C RING IS SMALLER SAVE IT
SMR=IT
DO 304 I32=1,IT
SMRAR(I32)=TEMAR(I32)
304 CONTINUE
GO TO 200
500 CONTINUE
C POP THE STACK
I2=I2-PC
IC=PUSH1(I2)
ID=PUSH1(I2+1)
IT=PUSH1(I2+2)
ICL=PUSH1(I2+3)
IF(I2 .NE. 1) GO TO 200
600 CONTINUE
C POPPED BACK TO BASE
IF(SMR .EQ. 1000) GO TO 10
C THERE IS A RING
C FIRST ATOM IN RING MUST BE POSITIONED
IF(AR(3,IC) .NE. 0) GO TO 606
C MARK THIS RING AS A NON CENTRAL RING
DO 607 I6=1,SMR
I61=SMRAR(I6)
ORING(I61)=ORC
607 CONTINUE
ORC=ORC+1
GO TO 10
606 CONTINUE
I77=SMRAR(2)
IF(AR(3,I77) .NE. 0) GO TO 77
C SECOND ATOM OF RING NOT POSITIONED
I78=SMRAR(SMR)
IF(AR(3,I78) .EQ. 0) GO TO 77
C LAST ATOM OF RING IS POSITIONED REVERSE THE RING LIST
DO 78 I79=SMR,2,-1
SMRAR(I79)=SMRAR(I79-1)
78 CONTINUE
SMRAR(1)=I78
77 CONTINUE
CALL POSITION (SMR,SMRAR,MODE,RET)
C IF NON CENTRAL RING CANT BE POSITIONED INCREASE LEG
IF(RET .NE. 0) RETURN
C ELIMINATE ATOMS IN RING WITH ONLY TWO RING NEIGHBORS
DO 601 I6=1,SMR
I61=SMRAR(I6)
I63=0
DO 602 I62=5,10
I622=AR(I62,I61)
IF(I622 .GT. 0 .AND. I622 .LT. 200) I63=I63+1
IF(I622 .LT. 200) GO TO 602
C PUT THIS BRANCH ON BRATAR
I622=I622-200
DO 6022 I6022=1,BRATC
IF(BRATAR(I6022) .EQ. I622) GO TO 602
6022 CONTINUE
C OK PUT IT ON
BRATC=BRATC+1
BRATAR(BRATC)=I622
602 CONTINUE
IF(I63 .NE. 2) GO TO 601
C ELIMINATE THIS ATOM
AR(1,I61)=AR(1,I61)+100
DO 603 I62=5,10
I64=AR(I62,I61)
IF(I64 .EQ. 0 .OR. I64 .GT. 100) GO TO 603
AR(I62,I61)=I64+100
DO 605 I65=5,10
IF(AR(I65 ,I64) .EQ. I61) GO TO 6061
605 CONTINUE
CALL WO ('R605')
6061 CONTINUE
AR(I65,I64)=AR(I65,I64)+100
603 CONTINUE
601 CONTINUE
GO TO 10
11 CONTINUE
END
SUBROUTINE BRANCH
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /RECC/ RECCNT,RECLIM
DATA RECLIM /300/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
RECCNT=0
DO 9 I9=1,6
REP=0
DO 10 I1=1,NUMB
IF(AR(3,I1) .NE. 0) GO TO 10
DO 20 I2=5,10
I3=AR(I2,I1)
IF(I3 .EQ. 0) GO TO 21
IF(I3 .GT. 100) I3=I3-100
IF(I3 .GT. 100) I3=I3-100
IF(AR(3,I3) .EQ. 0) GO TO 20
CALL RECPOS (I3,I1,RET)
IF(RECCNT .GE. RECLIM) RETURN
REP=REP+RET
GO TO 21
20 CONTINUE
21 CONTINUE
10 CONTINUE
IF(REP .EQ. 0 .AND. I9 .NE. 1) GO TO 99
9 CONTINUE
99 CONTINUE
END
SUBROUTINE WO (I17)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CREGNO/ REGNO
COMMON /CPOSW/ POSW
COMMON /CE2SW/ E2SW,E2CNT
DATA E2SW /0/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /IO/ CID,COD,E2CID
COMMON /CRPIC/ RHGH,RPIC(48)
E2CNT=E2CNT+1
IF(E2CNT .NE. 1) RETURN
WRITE (E2CID,102) REGNO
102 FORMAT(1X,1I9)
RHGH=1
TYPE 108
108 FORMAT(' STRUCTURE CANT BE DISPLAYED')
30 CONTINUE
DO 10 I1=1,NUMB
DO 20 I2=10,5,-1
IF(AR(I2,I1) .NE. 0) GO TO 21
20 CONTINUE
21 CONTINUE
IJK=MOD(AR(1,I1),100)
DO 930 I3=1,I2
AR(I3,I1)=MOD(AR(I3,I1),100)
930 CONTINUE
WRITE(5,101) IJK,AR(2,I1),(AR(I4,I1),I4=5,I2)
10 CONTINUE
101 FORMAT(1X,1I3,1X,1A2,1X,8I4)
NUMB=0
DO 50 I1=1,10
AR(I1,1)=0
50 CONTINUE
END
SUBROUTINE POSITION (CNT,STR,MODE,RET)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /FRDIR/ FRDIR
DIMENSION RNGDIR(56)
DATA (RNGDIR(I1),I1=1,56) /
1 3,3,1,1,2,2,2,3,
1 4,1,1,2,2,3,3,4,
1 5,5,1,2,2,3,4,5,
1 6,6,1,3,3,3,5,6,
1 7,7,1,3,3,4,6,7,
1 0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0/
DIMENSION TSTR(20)
COMMON /RNGGR/ RNGGR
COMMON /STPOS/ STPOS
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /REVT/ REVT(8)
DATA (REVT(I1),I1=1,8)/ 5,6,7,8,1,2,3,4/
DIMENSION STR(10)
DIMENSION DIRT(140)
DIMENSION T5(10,7),T6(12,7)
1 ,T7(14,7),T3(12,7),T4(8,7)
DATA (DIRT(I1),I1=1,140)/
1 0,0,0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0,
1 2,4,7,3,6,8,2,5,8,1,
1 4,6, 0,0,0,0,0,0,0,0,
1 1,3,5,7,2,4,6,8, 0,0,
1 0,0,0,0,0,0,0,0,0,0,
1 1,3,5,6,8,1,2,4,5,7,
1 0,0,0,0,0,0,0,0,0,0,
1 1,2,4,5,6,8,3,4,6,7,8,2,
1 0,0,0,0,0,0,0,0,
1 1,2,3,4,5,6,8,1,2,4,
1 5,6,7,8, 0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0/
DATA ((T3(I1,I2),I1=1,12),I2=1,7) /
1 5,6,4,3,1,2,12,10,11,8,9,7,
1 7,8,2,4,5,6,7,1,6,3,8,5,
1 4,5,2,10,7,8,4,1,8,3,5,7,
1 5,6,7,10,2,3,5,1,3,4,6,5,
1 12,14,3,13,2,4,12,1,4,5,14,2,
1 0,0,0,0,0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0,0,0/
DATA ((T4(I1,I2),I1=1,8 ),I2=1,7) /
1 8,3,4,10,5,6,1,2,
1 3,4,1,2,7,8,6,5,
1 3,10,1,2,4,5,7,8,
1 4,10,1,7,5,6,2,3,
1 5,13,1,3,12,14,2,4,
1 0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0/
DATA ((T5(I1,I2),I1=1,10),I2=1,7) /
1 8,3,10,1,2,8,5,6,10,4,
1 3,4,1,5,6,3,7,8,1,2,
1 3,10,1,7,8,3,4,5,1,2,
1 4,10,1,2,3,4,5,6,1,7,
1 5,13,1,2,4,5,12,14,1,3,
1 0,0,0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0/
DATA ((T6(I1,I2),I1=1,12),I2=1,7) /
1 8,5,6,10,1,2,3,6,1,4,2,5,
1 3,7,8,1,5,6,4,8,5,2,6,7,
1 3,4,5,1,7,8,10,5,7,2,8,4,
1 4,5,6,1,2,3,10,11,12,7,8,9,
1 5,12,14,1,2,4,13,14,2,3,4,12,
1 0,0,0,0,0,0,0,0,0,0,0,0,
1 0,0,0,0,0,0,0,0,0,0,0,0/
DATA ((T7(I1,I2),I1=1,14),I2=1,7) /
1 8,5,3,6,10,1,2,8,5,6,10,1,4,2,
1 3,7,4,8,1,5,6,3,7,8,1,5,2,6,
1 3,4,10,5,1,7,8,3,4,5,1,7,2,8,
1 4,5,10,6,1,2,3,4,5,6,1,2,7,3,
1 5,12,13,14,1,9,10,5,6,7,1,2,3,4,
1 0,0,0,0,0,0,0,0,0,0,0,0, 0,0,
1 0,0,0,0,0,0,0,0,0,0,0,0, 0,0/
DIMENSION LENT(140)
DATA (LENT(I1),I1=1,140)/
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,2,2,1,1,1,2,1,2,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,2,1,1,1,1,1,1,1,2,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,2,1,1,2,2,1,2,2,
1 1,1,2,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1/
COMMON /QSCALE/ SCALE
RET=0
IF(FRDIR .EQ. 0) GO TO 3000
FD1=((CNT-3)*8)+FRDIR
FRDIR=0
NPH=RNGDIR(FD1)
GO TO 1001
3000 CONTINUE
IF(STPOS .NE. 0) GO TO 13
STPOS=1
ORCNT=6
OPH=1
GO TO 14
13 CONTINUE
I1=STR(1)
DO 10 I2=5,10
IF(AR(I2,I1) .EQ. STR(2)) GO TO 11
10 CONTINUE
CALL WO ('WE10')
11 CONTINUE
ORCNT=BR(I2-4,I1)
I97=STR(2)
IF(ORCNT .GT. 100 .OR. AR(3,I97) .EQ. 0) GO TO 1002
I99=STR(1)
STR(1)=I97
STR(2)=I99
I95=3
DO 1004 I96=CNT,3,-1
TSTR(I95)=STR(I96)
I95=I95+1
1004 CONTINUE
DO 1003 I98=3,CNT
STR(I98)=TSTR(I98)
1003 CONTINUE
1002 CONTINUE
IF(ORCNT .GT. 100) ORCNT=ORCNT-100
OPH=CR(I2-4,I1)
12 CONTINUE
14 CONTINUE
GO TO (1,1,300,400,500,600,700,800,900),ORCNT
300 CONTINUE
NPH=T3(OPH,CNT-2)
GO TO 1000
400 CONTINUE
NPH=T4(OPH,CNT-2)
GO TO 1000
500 CONTINUE
NPH=T5(OPH,CNT-2)
GO TO 1000
600 CONTINUE
NPH=T6(OPH,CNT-2)
GO TO 1000
700 CONTINUE
NPH=T7(OPH,CNT-2)
GO TO 1000
1000 CONTINUE
IF(MODE .EQ. 0) GO TO 1001
C NON CENTRAL RING USE PHASE 1
NPH=1
1001 CONTINUE
OFF=(CNT-2)*20
QOFF=(((NPH-1)/ CNT)* CNT)+1
STR(CNT+1)=STR(1)
DO 20 I3=1,CNT
I4=DIRT(OFF+NPH)
I5=STR(I3)
I6=STR(I3+1)
IF(AR(3,I6) .NE. 0) GO TO 2200
LX=AR(3,I5)
LY=AR(4,I5)
GO TO (31,32,33,34,35,36,37,38),I4
31 CONTINUE
DX=0
DY=1
GO TO 39
32 CONTINUE
DX=1
DY=1
GO TO 39
33 CONTINUE
DX=1
DY=0
GO TO 39
34 CONTINUE
DX=1
DY=-1
GO TO 39
35 CONTINUE
DX=0
DY=-1
GO TO 39
36 CONTINUE
DX=-1
DY=-1
GO TO 39
37 CONTINUE
DX=-1
DY=0
GO TO 39
38 CONTINUE
DX=-1
DY=1
GO TO 39
39 CONTINUE
IL=LENT(OFF+NPH)
I92 =LX+(DX*SCALE*IL)
I93 =LY+(DY*SCALE*IL)
DO 2000 I91=1,NUMB
IF(AR(3,I91) .NE. I92) GO TO 2000
IF(I91 .EQ. I6) GO TO 2000
IF(AR(4,I91) .NE. I93) GO TO 2000
C NODE OVERLAP
C IF NON CENTRAL RING OVERLAPS BALK
IF(MODE .EQ. 0) GO TO 2002
RET=1
RETURN
2002 CONTINUE
I92=I92-20
I93=I93+20
GO TO 2001
2000 CONTINUE
2001 CONTINUE
AR(3,I6)=I92
AR(4,I6)=I93
2200 CONTINUE
DO 40 I7=5,10
IF(AR(I7,I5) .EQ. I6) GO TO 41
40 CONTINUE
CALL WO ('POS40')
41 CONTINUE
BR(I7-4,I5)=CNT
CR(I7-4,I5)=NPH
ER(I7-4,I5)=I4
DO 42 I8=5,10
IF(AR(I8,I6) .EQ. I5) GO TO 43
42 CONTINUE
CALL WO ('POS42')
43 CONTINUE
BR(I8-4,I6)=CNT +100
CR(I8-4,I6)=NPH
ER(I8-4,I6)=REVT(I4)
NPH=NPH+1
NPHT=MOD(NPH,CNT)
IF(NPHT .EQ. 1 ) NPH=QOFF
20 CONTINUE
IP=IP+1
IF(RNGGR .EQ. 1)
1 CALL GMOL (0)
RETURN
800 CONTINUE
900 CONTINUE
1 CONTINUE
CALL WO ('POEXT')
END
SUBROUTINE NDIRECT (I1,I2,I3,CNT,NDIR)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
DIMENSION BENDA(8)
DATA (BENDA(I1),I1=1,8)/ 4,7,7,7,2,3,3,3/
COMMON /IO/ CID,COD
COMMON /REVT/ REVT(8)
DIMENSION NDT(4,56)
DATA ((NDT(I1,I2),I1=1,4),I2=1,56) /
1 6,4,0,1, 8,2,0,5, 8,5,0,2, 1,6,0,4, 1,4,0,6, 5,2,0,8,
1 2,4,0,7, 8,6,0,3, 6,3,0,8, 2,7,0,4, 7,4,0,2, 3,8,0,6,
1 1,5,0,3, 5,1,0,7, 7,3,0,1, 3,7,0,5,
1 4,8,0,2, 6,2,0,8, 2,6,0,4, 8,4,0,6,
1 3,5,0,8, 5,7,0,2, 1,3,0,6, 1,7,0,4,
1 1,3,7,5, 5,3,7,1, 1,5,3,7, 1,5,7,3,
1 2,4,8,6, 2,6,8,4, 4,2,6,8, 4,8,6,2,
1 2,5,8,1, 4,1,6,5, 3,6,8,7, 2,4,7,3,
1 7,4,1,8, 3,5,8,6, 5,7,2,8, 1,3,6,4,
1 1,4,5,7, 1,5,6,3, 1,5,8,3, 1,2,5,7,
1 1,2,6,4, 2,6,7,4, 2,3,6,8, 2,5,6,8,
1 1,4,8,6, 3,4,8,6, 4,5,8,2, 4,7,8,2,
1 3,7,8,5, 3,6,7,1, 2,3,7,5, 3,4,7,1/
NDIR=0
IF(I2 .NE. 0) GO TO 12
NDIR=REVT(I1)
IF(BENDARM .EQ. 2) NDIR=BENDA(I1)
GO TO 11
RETURN
12 CONTINUE
I41=1
IF(I3 .NE. 0) I41=25
DO 10 I4=I41,56
CALL ND1(I1,I2,I3,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
IF(I4 .GE. 13 .AND. I4 .LE. 20) GO TO 10
CALL ND1(I1,I3,I2,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I2,I1,I3,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I2,I3,I1,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I3,I1,I2,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I3,I2,I1,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
10 CONTINUE
CALL WO ('ND10')
C WRITE(COD,101) I1,I2,I3
C101 FORMAT(1X,3I4)
RETURN
11 CONTINUE
IF(CNT .EQ. 0) GO TO 20
C SAME DIRECTION GENERATED AGAIN
IF(CNT .EQ. 1) NDIR=MOD(NDIR,8)+1
IF(CNT .NE. 2) GO TO 30
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
30 CONTINUE
IF(CNT .NE. 3) GO TO 40
NDIR=MOD(NDIR,8)+1
NDIR=MOD(NDIR,8)+1
40 CONTINUE
IF(CNT .NE. 4) GO TO 50
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
50 CONTINUE
RETURN
20 CONTINUE
END
SUBROUTINE ND1 (I1,I2,I3,QAR,NDIR)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
DIMENSION QAR(4)
NDIR=0
IF(I1 .EQ. QAR(1) .AND. I2 .EQ. QAR(2) .AND. I3 .EQ. QAR(3))
1 NDIR=QAR(4)
END
SUBROUTINE INTERSECT (I1,I2,RET)
C-------------------------------------------------------------------------------
REAL MM,QM,MC,QC,MX,MY,M1X,M1Y,M2X,M2Y,M3X,M3Y,M4X,M4Y,TT,TB
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
RET=0
I1X=AR(3,I1)
I1Y=AR(4,I1)
I2X=AR(3,I2)
I2Y=AR(4,I2)
MM=1000000.
TT=I1Y-I2Y
TB=I1X-I2X
IF(I1X .NE. I2X) MM=TT/TB
M1X=I1X
M1Y=I1Y
M2X=I2X
M2Y=I2Y
MC=M2Y-(MM*M2X)
DO 10 I3=1,NUMB
IF(I3 .EQ. I1 .OR. I3 .EQ. I2) GO TO 10
I3X=AR(3,I3)
IF(I3X .EQ. 0) GO TO 10
I3Y=AR(4,I3)
M3X=I3X
M3Y=I3Y
DO 20 I4=5,10
I41=AR(I4,I3)
IF(I41 .EQ. 0) GO TO 10
IF(I41 .LT. I3) GO TO 20
IF(I41 .GT. 100) I41=I41-100
IF(I41 .GT. 100) I41=I41-100
IF(I41 .EQ. I1 .OR. I41 .EQ. I2) GO TO 20
I4X=AR(3,I41)
IF(I4X .EQ. 0) GO TO 20
I4Y=AR(4,I41)
C GOT 4 POINTS
QM=1000000.
TT=I3Y-I4Y
TB=I3X-I4X
IF(I3X .NE. I4X)QM=TT/TB
M4X=I4X
M4Y=I4Y
QC=M4Y-(QM*M4X)
IF(QM.EQ.MM) GO TO 21
MX=(QC-MC)/(MM-QM)
IF((M1X-MX)*(MX-M2X).GE.0.AND.(M3X-MX)*(MX-M4X).GE.0) GO TO 60
GO TO 20
21 IF(MC.NE.QC) GO TO 20
IF(ABS(QM).GT.1.0) GO TO 22
IF((M1X-M3X)*(M3X-M2X).GE.0.OR.(M1X-M4X)*(M4X-M2X).GE.0)GOTO60
GO TO 20
22 CONTINUE
IF((M1Y-M3Y)*(M3Y-M2Y).GE.0.OR.(M1Y-M4Y)*(M4Y-M2Y).GE.0) GO TO 60
20 CONTINUE
10 CONTINUE
RETURN
60 CONTINUE
RET=1
END
SUBROUTINE RECPOS (LAT,NAT,RET)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /REVT/ REVT(8)
COMMON /FRDIR/ FRDIR
COMMON /QSCALE/ SCALE
COMMON /RECC/ RECCNT,RECLIM
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /OTHRING/ ORC,ORING(100)
DIMENSION NDAR(3)
PL=12
IP3=1
I2=10
LC=LAT
NC=NAT
600 CONTINUE
IF(I2 .LE. P2LIM) GO TO 5051
TYPE 5052
RECCNT=1000000
RETURN
5052 FORMAT(' PUSH2 OVERFLOW'/)
5051 CONTINUE
DISC=0
DIRC=0
RNGSW=1
RNG=0
RET=0
400 CONTINUE
C BEGIN TO POSITION THIS ATOM
C ASSUMES THAT NEIGHBORS ARE ORDERED ACCORDING TO LENGTH
NDAR(1)=0
NDAR(2)=0
NDAR(3)=0
I41=1
DO 401 I4=5,10
I42=AR(I4,LC)
IF(I42 .EQ. 0) GO TO 4205
IF(I42 .GT. 100) I42=I42-100
IF(I42 .GT. 100) I42=I42-100
IF(AR(3,I42) .EQ. 0) GO TO 401
C FOUND A NEIGHBOR ON LAT WHICH IS POSITIONED
NDAR(I41)=ER(I4-4,LC)
I41=I41+1
401 CONTINUE
4205 CONTINUE
IF(I41 .NE. 1) GO TO 420
C NO NEIGHBORS ARE SET USE DIRECTION 3
NDIR=3
GO TO 471
420 CONTINUE
CALL NDIRECT (NDAR(1),NDAR(2),NDAR(3),DIRC,NDIR)
471 CONTINUE
RECCNT=RECCNT+1
IF(RECCNT .GE. RECLIM) RETURN
C CHANGE LENGTH OF ARM
DISC=DISC+1
IF(DISC .LE. 5) GO TO 410
470 CONTINUE
C CHANGE DIRECTION
DISC=0
DIRC=DIRC+1
IF(DIRC .GE. 4) GO TO 502
C CLEAR POSITIONING OF ATOM
AR(3,NC)=0
AR(4,NC)=0
NCP1=NC+100
NCP2=NC+200
DO 531 I431=5,10
I432=AR(I431,LC)
IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
1 GO TO 532
531 CONTINUE
CALL WO ('RP531')
532 CONTINUE
ER(I431-4,LC)=0
LCP1=LC+100
LCP2=LC+200
DO 533 I433=5,10
I434=AR(I433,NC)
IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
1 GO TO 534
533 CONTINUE
CALL WO ('RP533')
534 CONTINUE
ER(I433-4,NC)=0
I411X=AR(3,NC)
I411Y=AR(4,NC)
GO TO 420
410 CONTINUE
GO TO (411,412,413,414,415,416,417,418),NDIR
411 CONTINUE
AR(3,NC)=AR(3,LC)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
412 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
413 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)
GO TO 430
414 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
415 CONTINUE
AR(3,NC)=AR(3,LC)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
416 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
417 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)
GO TO 430
418 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
430 CONTINUE
IF(I411X .EQ. 0 .OR. (I411X .EQ. AR(3,NC) .AND.
1 I411Y .EQ. AR(4,NC))) GO TO 4119
C WRITE(COD,4118) I411X,I411Y,AR(3,NC),AR(4,NC)
C4118 FORMAT(' OLD ',2I5,' NEW ',2I5)
AR(3,NC)=I411X
AR(4,NC)=I411Y
4119 CONTINUE
CALL INTERSECT (LC,NC,RET)
IF(RET .NE. 1) GO TO 4717
AR(3,NC)=0
AR(4,NC)=0
GO TO 470
4717 CONTINUE
NCP1=NC+100
NCP2=NC+200
DO 431 I431=5,10
I432=AR(I431,LC)
IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
1 GO TO 432
431 CONTINUE
CALL WO ('RP431')
432 CONTINUE
ER(I431-4,LC)=NDIR
LCP1=LC+100
LCP2=LC+200
DO 433 I433=5,10
I434=AR(I433,NC)
IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
1 GO TO 434
433 CONTINUE
CALL WO ('RP433')
434 CONTINUE
ER(I433-4,NC)=REVT(NDIR)
IF(ORING(NC) .EQ. 0) GO TO 480
IF(DISC .LT. 2) GO TO 471
C NON CENTRAL RING
FRDIR=NDIR
CALL RINGGG (NC,PUSH3(IP3),RNG,RET)
IF(RET .EQ. 1) GO TO 470
I5=0
RNGSW=2
540 CONTINUE
I5=I5+1
IF(I5 .GT. RNG) GO TO 500
I55=PUSH3(IP3+I5-1)
DO 541 I54=5,10
I51=AR(I54,I55)
IF(I51 .EQ. 0) GO TO 540
IF(I51 .LE. 200) GO TO 541
I51=I51-200
IF(AR(3,I51) .NE. 0) GO TO 542
541 CONTINUE
CALL WO ('RP541')
542 CONTINUE
C SAVE THIS ATOM
PUSH2(I2)=LC
PUSH2(I2+1)=NC
PUSH2(I2+2)=DISC
PUSH2(I2+3)=DIRC
PUSH2(I2+4)=I5
PUSH2(I2+5)=RNG
PUSH2(I2+6)=IP3
PUSH2(I2+7)=RNGSW
PUSH2(I2+8)=I51
PUSH2(I2+9)=NDAR(1)
PUSH2(I2+10)=NDAR(2)
PUSH2(I2+11)=NDAR(3)
IP3=IP3+RNG
IF(IP3 .LE. P3LIM) GO TO 5055
TYPE 5056
RECCNT=1000000
RETURN
5056 FORMAT(' PUSH3 OVERFLOW'/)
5055 CONTINUE
I2=I2+PL
LC=I51
NC=I55
GO TO 600
480 CONTINUE
I5=4
440 CONTINUE
I5=I5+1
IF(I5 .GT. 10) GO TO 500
I51=AR(I5,NC)
IF(I51 .LT. 200) GO TO 440
I51=I51-200
IF(AR(3,I51) .NE. 0) GO TO 440
C SAVE THIS ATOM
PUSH2(I2)=LC
PUSH2(I2+1)=NC
PUSH2(I2+2)=DISC
PUSH2(I2+3)=DIRC
PUSH2(I2+4)=I5
PUSH2(I2+5)=RNG
PUSH2(I2+6)=IP3
PUSH2(I2+7)=RNGSW
PUSH2(I2+8)=I51
PUSH2(I2+9)=NDAR(1)
PUSH2(I2+10)=NDAR(2)
PUSH2(I2+11)=NDAR(3)
I2=I2+PL
LC=NC
NC=I51
GO TO 600
502 CONTINUE
RET=1
500 CONTINUE
I2=I2-PL
IF(I2 .LE. 1) GO TO 700
LC=PUSH2(I2)
NC=PUSH2(I2+1)
DISC=PUSH2(I2+2)
DIRC=PUSH2(I2+3)
I5=PUSH2(I2+4)
RNG=PUSH2(I2+5)
IP3=PUSH2(I2+6)
RNGSW=PUSH2(I2+7)
I51=PUSH2(I2+8)
NDAR(1)=PUSH2(I2+9 )
NDAR(1)=PUSH2(I2+10)
NDAR(1)=PUSH2(I2+11)
IF(RET .EQ. 0) GO TO 501
RET=0
CALL UNPOS (NC)
GO TO 471
501 CONTINUE
GO TO (440,540),RNGSW
700 CONTINUE
END
SUBROUTINE UNPOS (NC)
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /PUSH4/ PUSH4(100)
IP4=2
PUSH4(1)=NC
PUSH4(2)=0
DO 10 PP4=1,100
PN=PUSH4(PP4)
IF(PN .EQ. 0) GO TO 11
AR(3,PN)=0
AR(4,PN)=0
DO 20 I1=5,10
I2=AR(I1,PN)
IF(I2 .EQ. 0 .OR. DR(I1-4,PN) .EQ. 0) GO TO 20
IF(I2 .GT. 100) I2=I2-100
IF(I2 .GT. 100) I2=I2-100
IF(AR(3,I2) .EQ. 0) GO TO 20
PUSH4(IP4)=I2
PUSH4(IP4+1)=0
IP4=IP4+1
20 CONTINUE
10 CONTINUE
11 CONTINUE
END
SUBROUTINE ELIMEND
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
DIMENSION TAR1(10),TAR2(10)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
DO 60 I1=1,NUMB
IF(AR(6,I1) .NE. 0) GO TO 60
C ONLY ONE ATTACHMENT
I2=AR(5,I1)
DO 61 I3=5,10
IF(AR(I3,I2) .EQ. I1) GO TO 62
61 CONTINUE
CALL WO ('EE60')
62 CONTINUE
DR(I3,I2)=1
AR(1,I1)=AR(1,I1)+200
60 CONTINUE
40 CONTINUE
FND=0
DO 10 I1=NUMB,1,-1
IF(AR(1,I1) .GT. 100) GO TO 10
I3=0
DO 20 I2=5,10
IF(AR(I2,I1) .EQ. 0) GO TO 20
IF(AR(I2,I1) .GT. 200) GO TO 20
I3=I3+1
I4=AR(I2,I1)
I41=I2
20 CONTINUE
IF(I3 .GT. 1 .OR. I3 .EQ. 0) GO TO 10
AR(I41,I1)=AR(I41,I1)+200
FND=1
I8=0
DO 400 I9=1,6
IF(DR(I9,I1) .GT. I8) I8=DR(I9,I1)
400 CONTINUE
DO 30 I2=5,10
IF(AR(I2,I4) .EQ. I1) GO TO 31
30 CONTINUE
CALL WO ('EE30')
31 CONTINUE
AR(I2,I4)=AR(I2,I4)+200
AR(1,I1)=AR(1,I1)+200
DR(I2-4,I4)=I8+1
10 CONTINUE
IF(FND .EQ. 1) GO TO 40
DO 50 I1=1,NUMB
IF(AR(1,I1) .LT. 200) GO TO 50
51 CONTINUE
I5=1
DO 95 I2=1,6
TAR1(I2)=0
TAR2(I2)=0
IF(AR(I2+4,I1) .EQ. 0 .OR. DR(I2,I1) .NE. 0 ) GO TO 95
TAR1(I5)=DR(I2,I1)
TAR2(I5)=AR(I2+4,I1)
I5=I5+1
95 CONTINUE
DO 80 I2=1,6
I4=0
DO 70 I3=1,6
IF(DR(I3,I1) .LE. TAR1(I2)) GO TO 70
TAR1(I5)=DR(I3,I1)
TAR2(I5)=AR(I3+4,I1)
I4=I3
70 CONTINUE
IF(I4 .EQ. 0) GO TO 81
DR(I4,I1)=-1
I5=I5+1
80 CONTINUE
81 CONTINUE
DO 90 I2=1,6
AR(I2+4,I1)=TAR2(I2)
DR(I2,I1)=TAR1(I2)
90 CONTINUE
50 CONTINUE
END
SUBROUTINE SAFMAF
C-------------------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
DIMENSION STPAR(12)
DATA (STPAR(I1),I1=1,12) /500,500,700,700,300,300
1 ,700,300,300,700,300,500/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /PUSH4/ PUSH4(100)
STC=1
DO 30 I3=1,NUMB
IF(AR(3,I3) .NE. 0 .AND. I3 .NE. 1) GO TO 30
AR(3,I3)=STPAR(STC)
AR(4,I3)=STPAR(STC+1)
STC=STC+2
IP4=2
PUSH4(1)=I3
PUSH4(2)=0
DO 10 PP4=1,100
PN=PUSH4(PP4)
IF(PN .EQ. 0) GO TO 11
DO 20 I1=5,10
I2=AR(I1,PN)
IF(I2 .EQ. 0) GO TO 20
IF(AR(3,I2) .NE. 0) GO TO 20
AR(3,I2)=AR(3,I2)-1
PUSH4(IP4)=I2
PUSH4(IP4+1)=0
IP4=IP4+1
20 CONTINUE
10 CONTINUE
11 CONTINUE
30 CONTINUE
DO 40 I1=1,NUMB
AR(3,I1)=AR(3,I1)+1
40 CONTINUE
END
SUBROUTINE NMORGAN
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(1000)
COMMON /IO/ CID,COD,FILSIZ,ICNT
COMMON /CPOSW/ POSW
COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
1 ,Z(2,100),ATS(100),AT(100),ASS(100)
1 ,SUBQ(100),SUBS(100),SUBT(100)
DIMENSION ZS(2)
EQUIVALENCE (ZS(1),Z(1,1))
I11=0
DO 10 I1=1,NUMB
DO 20 I2=5,10
IF(AR(I2+I11) .EQ. 0) GO TO 21
20 CONTINUE
I2=11
21 CONTINUE
AT(I1)=AR(2+I11)
I2=I2-5
NN(I1)=I2
EV(I1)=I2
SA(I1)=I2
I11=I11+10
10 CONTINUE
OK=0
30 CONTINUE
CALL SORT (SA,NUMB,1)
NK=1
I2=SA(1)
PST(1)=EV(1)
DO 50 I1=2,NUMB
PST(I1)=EV(I1)
IF(SA(I1) .EQ. I2) GO TO 50
NK=NK+1
I2=SA(I1)
50 CONTINUE
IF(NK .LE. OK) GO TO 51
OK=NK
I11=0
DO 60 I1=1,NUMB
I2=NN(I1)
I5=0
IF(I2 .EQ. 0) GO TO 72
DO 70 I3=1,I2
I4=AR(I3+4+I11)
IF(I4 .GE. 1 .AND. I4 .LE. 100) GO TO 71
TYPE 101,I1,I2
101 FORMAT(' NMORGAN ',2I3/)
RETURN
71 CONTINUE
I5=I5+PST(I4)
70 CONTINUE
72 CONTINUE
EV(I1)=I5
SA(I1)=I5
I11=I11+10
60 CONTINUE
GO TO 30
51 CONTINUE
IF(POSW .NE. 0) GO TO 89
KUMB=(NUMB*10)
WRITE (COD,102)(AR(I111),I111=1,KUMB,10)
WRITE(COD,102)(EV(I111),I111=1,NUMB)
102 FORMAT(1X,30I4)
WRITE(COD,102)(SA(I111),I111=1,NUMB)
89 CONTINUE
DO 82 I1=1,NUMB
ATS(I1)=0
82 CONTINUE
I13=SA(NUMB)
DO 90 I1=NUMB,1,-1
IF(EV(I1) .NE. I13) GO TO 90
DO 80 I2=1,NUMB
PST(I2)=0
80 CONTINUE
I2=0
I3=1
SA(1)=I1
120 CONTINUE
I2=I2+1
IF(I2 .GT. I3) GO TO 121
I4=SA(I2)
I44=(I4-1)*10
I5=NN(I4)
IF(I5 .EQ. 0) GO TO 132
K6=0
DO 100 I6=1,I5
I7=AR(I6+4+I44)
ZS(3+K6)=I7
ZS(1+K6)=EV(I7)
ZS(2+K6)=AT(I7)
K6=K6+3
100 CONTINUE
CALL SORT (Z,I5,3)
K6=(I5-1)*3
DO 110 I6=I5,1,-1
I8=ZS(3+K6)
DO 130 I7=1,I3
IF(I8 .EQ. SA(I7)) GO TO 131
130 CONTINUE
132 CONTINUE
I3=I3+1
SA(I3)=I8
PST(I3)=AT(I8)
IF(AT(I8) .LT. ATS(I3)) GO TO 90
C THE ATOM SEQUENCE OF DEVELOPING STRUCTURE IS GTE
IF(AT(I8) .EQ. ATS(I3)) GO TO 138
131 CONTINUE
DO 139 I18=1,NUMB
ATS(I18)=0
139 CONTINUE
138 CONTINUE
K6=K6-3
110 CONTINUE
GO TO 120
121 CONTINUE
DO 140 I2=1,NUMB
ATS(I2)=PST(I2)
ASS(I2)=SA(I2)
140 CONTINUE
I11=I1
90 CONTINUE
DO 150 I1=1,NUMB
Z(2,I1)=I1
Z(1,I1)=ASS(I1)
150 CONTINUE
CALL SORT (Z,NUMB,2)
IF(POSW .EQ. 0)
1 WRITE(COD,102)(Z(1,I111),Z(2,I111),I111=1,NUMB)
I11=0
DO 160 I1=1,NUMB
I2=NN(I1)
DO 170 I3=1,I2
I4=AR(I3+4+I11)
AR(I3+4+I11)=Z(2,I4)
170 CONTINUE
AR(1+I11)=Z(2,I1)
IF(I2 .GT. 1) CALL SORT (AR(5+I11),I2,1)
I11=I11+10
160 CONTINUE
CALL SORT (AR,NUMB,10)
C IF(POSW .EQ. 0) CALL PRAR (AR,NUMB,'NMORG')
END